home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue58 / DragDrop / COMDragDropSupport.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-05-04  |  15.1 KB  |  512 lines
  1. unit COMDragDropSupport;
  2.  
  3. interface
  4.  
  5. uses
  6.   Forms, ActiveX, Classes, Windows, ShellAPI, Graphics;
  7.                                
  8. type
  9.   //When adding to this set, update the GetDataFormats function as well
  10.   TDataFormat = (dfText, dfHDrop, dfDIB, dfBitmap, dfPalette,
  11.     dfWMF, dfEMF, dfRTF, dfFileName, dfShellIDList, 
  12.     dfObjectDescriptor, dfLinkSrcDescriptor);
  13.   TDataFormats = set of TDataFormat;
  14.  
  15.   TDataObject = class
  16.   private
  17.     FDataObject: IDataObject;
  18.     FFormatEtc: TFormatEtc;
  19.     FDataFormats: TDataFormats;
  20.     //Stores data object's data formats in FDataFormats
  21.     procedure GetDataFormats;
  22.     procedure SetupFormatEtc(ClipFmt: TClipFormat; TyMed: Longint);
  23.     procedure GetDescriptor(SM: TStgMedium; List: TStrings);
  24.   public
  25.     constructor Create(DataObj: IDataObject);
  26.     procedure GetDataAsBitmap(Bmp: TBitmap);
  27.     procedure GetDataAsDIB(Bmp: TBitmap);
  28.     procedure GetDataAsHDrop(FileList: TStrings);
  29.     procedure GetDataAsWMF(MetaFile: TMetaFile);
  30.     procedure GetDataAsEMF(MetaFile: TMetafile);
  31.     procedure GetDataAsPalette(Bmp: TBitmap);
  32.     procedure GetDataAsRTF(var Txt: String);
  33.     procedure GetDataAsText(var Txt: String);
  34.     procedure GetDataAsFileName(var Txt: String);
  35.     procedure GetDataAsShellIDList(IDList: TStrings);
  36.     procedure GetDataAsObjectDescriptor(ObjDescList: TStrings);
  37.     procedure GetDataAsLinkSrcDescriptor(LinkSrcDescList: TStrings);
  38.     procedure ListFormats(List: TStrings);
  39.     property DataFormats: TDataFormats read FDataFormats;
  40.   end; //TDataObject
  41.  
  42. //Turn clipboard format constant into the appropriate descriptive string
  43. function ClipFormatToStr(Fmt: TClipFormat): String;
  44. //Turn a storage medium type constant into descriptive string
  45. function TyMedToStr(TyMed: Longint): String;
  46.  
  47. implementation
  48.  
  49. uses
  50.   ClipBrd, ComObj, SysUtils, ShlObj;
  51.  
  52. var
  53.   CF_RTF,
  54.   CF_FILENAME,
  55.   CF_IDLIST,
  56.   CF_OBJECTDESCRIPTOR,
  57.   CF_LINKSRCDESCRIPTOR: TClipFormat;
  58.  
  59. function ClipFormatToStr(Fmt: TClipFormat): String;
  60. var
  61.   Buf: array[0..255] of Char;
  62. begin
  63.   GetClipboardFormatName(Fmt, Buf, SizeOf(Buf));
  64.   Result := String(Buf);
  65.   if Result = '' then
  66.     case Fmt of
  67.       CF_TEXT:            Result := 'CF_TEXT';
  68.       CF_BITMAP:          Result := 'CF_BITMAP';
  69.       CF_METAFILEPICT:    Result := 'CF_METAFILEPICT';
  70.       CF_SYLK:            Result := 'CF_SYLK';
  71.       CF_DIF:             Result := 'CF_DIF';
  72.       CF_TIFF:            Result := 'CF_TIFF';
  73.       CF_OEMTEXT:         Result := 'CF_OEMTEXT';
  74.       CF_DIB:             Result := 'CF_DIB';
  75.       CF_PALETTE:         Result := 'CF_PALETTE';
  76.       CF_PENDATA:         Result := 'CF_PENDATA';
  77.       CF_RIFF:            Result := 'CF_RIFF';
  78.       CF_WAVE:            Result := 'CF_WAVE';
  79.       CF_UNICODETEXT:     Result := 'CF_UNICODETEXT';
  80.       CF_ENHMETAFILE:     Result := 'CF_ENHMETAFILE';
  81.       CF_HDROP:           Result := 'CF_HDROP';
  82.       CF_LOCALE:          Result := 'CF_LOCALE';
  83.       CF_OWNERDISPLAY:    Result := 'CF_OWNERDISPLAY';
  84.       CF_DSPTEXT:         Result := 'CF_DSPTEXT';
  85.       CF_DSPBITMAP:       Result := 'CF_DSPBITMAP';
  86.       CF_DSPMETAFILEPICT: Result := 'CF_DSPMETAFILEPICT';
  87.       CF_DSPENHMETAFILE:  Result := 'CF_DSPENHMETAFILE';
  88.     else
  89.       Result := 'Unknown clipboard format'
  90.     end
  91. end;
  92.  
  93. function TyMedToStr(TyMed: Longint): String;
  94. begin
  95.   Result := 'Unknown medium type';
  96.   case TyMed of
  97.     TYMED_NULL: Result := 'TYMED_NULL';
  98.     TYMED_HGLOBAL: Result := 'TYMED_HGLOBAL';
  99.     TYMED_FILE: Result := 'TYMED_FILE';
  100.     TYMED_ISTREAM: Result := 'TYMED_ISTREAM';
  101.     TYMED_ISTORAGE: Result := 'TYMED_ISTORAGE';
  102.     TYMED_GDI: Result := 'TYMED_GDI';
  103.     TYMED_MFPICT: Result := 'TYMED_MFPICT';
  104.     TYMED_ENHMF: Result := 'TYMED_ENHMF';
  105.   end;
  106. end;
  107.  
  108. { TDataObject }
  109.  
  110. constructor TDataObject.Create(DataObj: IDataObject);
  111. begin
  112.   inherited Create;
  113.   FDataObject := DataObj;
  114.   GetDataFormats
  115. end;
  116.  
  117. procedure TDataObject.GetDataFormats;
  118.  
  119.   procedure GetDataFormat(ClipFmt: TClipFormat; TyMed: Longint; Format: TDataFormat);
  120.   begin
  121.     SetupFormatEtc(ClipFmt, TyMed);
  122.     if FDataObject.QueryGetData(FFormatEtc) = S_OK then
  123.       Include(FDataFormats, Format);
  124.   end;
  125.  
  126. begin
  127.   FDataFormats := [];
  128.   GetDataFormat(CF_BITMAP,            TYMED_GDI,     dfBitmap);
  129.   GetDataFormat(CF_DIB,               TYMED_HGLOBAL, dfDIB);
  130.   GetDataFormat(CF_HDROP,             TYMED_HGLOBAL, dfHDrop);
  131.   GetDataFormat(CF_METAFILEPICT,      TYMED_MFPICT,  dfWMF);
  132.   GetDataFormat(CF_ENHMETAFILE,       TYMED_ENHMF,   dFEMF);
  133.   GetDataFormat(CF_PALETTE,           TYMED_GDI,     dfPalette);
  134.   GetDataFormat(CF_TEXT,              TYMED_HGLOBAL, dfText);
  135.   GetDataFormat(CF_RTF,               TYMED_HGLOBAL, dfRTF);
  136.   GetDataFormat(CF_FILENAME,          TYMED_HGLOBAL, dfFileName);
  137.   GetDataFormat(CF_IDLIST,            TYMED_HGLOBAL, dfShellIDList);
  138.   GetDataFormat(CF_OBJECTDESCRIPTOR,  TYMED_HGLOBAL, dfObjectDescriptor);
  139.   GetDataFormat(CF_LINKSRCDESCRIPTOR, TYMED_HGLOBAL, dfLinkSrcDescriptor);
  140. end;
  141.  
  142. procedure TDataObject.ListFormats(List: TStrings);
  143. var
  144.   EFE: IEnumFormatEtc;
  145.   FE: TFormatEtc;
  146.   CElt: Longint;
  147. begin
  148.   if not Assigned(List) then
  149.     Exit;
  150.   OleCheck(FDataObject.EnumFormatEtc(DATADIR_GET, EFE));
  151.   List.Clear;
  152.   repeat
  153.     OleCheck(EFE.Next(1, FE, @CElt));
  154.     if CElt > 0 then
  155.       List.Add(Format('%s (%s)',
  156.         [ClipFormatToStr(FE.cfFormat),
  157.          TyMedToStr(FE.tymed)]));
  158.   until CElt = 0;
  159. end;
  160.  
  161. procedure TDataObject.SetupFormatEtc(ClipFmt: TClipFormat; TyMed: Longint);
  162. begin
  163.   FFormatEtc.cfFormat := ClipFmt;
  164.   FFormatEtc.tymed := TyMed;
  165.   FFormatEtc.ptd := nil;
  166.   FFormatEtc.dwAspect := DVASPECT_CONTENT;
  167.   FFormatEtc.lindex := -1;
  168. end;
  169.  
  170. procedure TDataObject.GetDataAsBitmap(Bmp: TBitmap);
  171. var
  172.   SM: TStgMedium;
  173. begin
  174.   if not Assigned(Bmp) then
  175.     Exit;
  176.   SetupFormatEtc(CF_BITMAP, TYMED_GDI);
  177.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  178.   try
  179.     //Use a handy shortcut to load bitmp
  180.     Bmp.LoadFromClipboardFormat(CF_BITMAP, SM.hBitmap, 0);
  181.     if dfPalette in DataFormats then
  182.       GetDataAsPalette(Bmp)
  183.   finally
  184.     ReleaseStgMedium(SM)
  185.   end
  186. end;
  187.  
  188. procedure TDataObject.GetDataAsDIB(Bmp: TBitmap);
  189. var
  190.   SM: TStgMedium;
  191.   Stream: TMemoryStream;
  192.   DIBPtr: Pointer;
  193.   DIBSize: DWord;
  194.   BMF: TBitmapFileHeader;
  195. begin
  196.   if not Assigned(Bmp) then
  197.     Exit;
  198.   SetupFormatEtc(CF_DIB, TYMED_HGLOBAL);
  199.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  200.   try
  201.     DIBSize := GlobalSize(SM.hGlobal);
  202.     DIBPtr := GlobalLock(SM.hGlobal);
  203.     try
  204.       Stream := TMemoryStream.Create;
  205.       try
  206.         //Write a bitmap file header record
  207.         FillChar(BMF, sizeof(BMF), 0);
  208.         BMF.bfType := $4D42;
  209.         BMF.bfSize := SizeOf(BMF) + DIBSize;
  210.         Stream.Write(BMF, SizeOf(BMF));
  211.         //Follow the BMF with the DIB
  212.         Stream.Write(DIBPtr^, DIBSize);
  213.         Stream.Position := 0;
  214.         //Load the finished DIB into a TBitmap
  215.         Bmp.LoadFromStream(Stream)
  216.       finally
  217.         Stream.Free
  218.       end
  219.     finally
  220.       GlobalUnlock(SM.hGlobal)
  221.     end
  222.   finally
  223.     ReleaseStgMedium(SM)
  224.   end
  225. end;
  226.  
  227. procedure TDataObject.GetDataAsHDrop(FileList: TStrings);
  228. var
  229.   SM: TStgMedium;
  230.   Count, Loop: Integer;
  231.   Buf: array[0..1023] of Char;
  232. begin
  233.   if not Assigned(FileList) then
  234.     Exit;
  235.   SetupFormatEtc(CF_HDROP, TYMED_HGLOBAL);
  236.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  237.   try
  238.     //How many files were dragged?
  239.     Count := DragQueryFile(SM.hGlobal, Cardinal(-1), nil, 0);
  240.     FileList.BeginUpdate;
  241.     try
  242.       FileList.Clear;
  243.       //Loop through files
  244.       for Loop := 0 to Pred(Count) do
  245.       begin
  246.         //Get filename
  247.         DragQueryFile(SM.hGlobal, Loop, Buf, SizeOf(Buf));
  248.         FileList.Add(Buf)
  249.       end
  250.     finally
  251.       FileList.EndUpdate
  252.     end
  253.   finally
  254.     ReleaseStgMedium(SM)
  255.   end
  256. end;
  257.  
  258. procedure TDataObject.GetDataAsWMF(MetaFile: TMetaFile);
  259. var
  260.   SM: TStgMedium;
  261.   MPPtr: PMetaFilePict;
  262.   MFBufSize: DWord;
  263.   MFBuf: Pointer;
  264. begin
  265.   if not Assigned(MetaFile) then
  266.     Exit;
  267.   SetupFormatEtc(CF_METAFILEPICT, TYMED_MFPICT);
  268.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  269.   try
  270.     //Get access to the TMetaFilePict record
  271.     MPPtr := GlobalLock(SM.hMetaFilePict);
  272.     try
  273.       //How big is the metafile?
  274.       MFBufSize := GetMetaFileBitsEx(MPPtr^.hMF, 0, nil);
  275.       //Allocate sufficient buffer space
  276.       GetMem(MFBuf, MFBufSize);
  277.       try
  278.         //Copy metafile to buffer
  279.         Win32Check(LongBool(
  280.           GetMetaFileBitsEx(MPPtr^.hMF, MFBufSize, MFBuf)));
  281.         //Generate enhanced metafile from buffer
  282.         MetaFile.Handle := SetWinMetaFileBits(MFBufSize, MFBuf, 0, MPPtr^)
  283.       finally
  284.         //Free buffer
  285.         FreeMem(MFBuf)
  286.       end
  287.     finally
  288.       //Unlock memory handle
  289.       GlobalUnlock(SM.hMetaFilePict)
  290.     end
  291.   finally
  292.     ReleaseStgMedium(SM)
  293.   end
  294. end;
  295.  
  296. procedure TDataObject.GetDataAsEMF(MetaFile: TMetafile);
  297. var
  298.   SM: TStgMedium;
  299. begin
  300.   if not Assigned(MetaFile) then
  301.     Exit;
  302.   SetupFormatEtc(CF_ENHMETAFILE, TYMED_ENHMF);
  303.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  304.   try
  305.     MetaFile.Handle := CopyEnhMetafile(SM.hEnhMetaFile, nil)
  306.   finally
  307.     ReleaseStgMedium(SM)
  308.   end
  309. end;
  310.  
  311. procedure TDataObject.GetDataAsPalette(Bmp: TBitmap);
  312. var
  313.   SM: TStgMedium;
  314. begin
  315.   if not Assigned(Bmp) then
  316.     Exit;
  317.   SetupFormatEtc(CF_PALETTE, TYMED_GDI);
  318.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  319.   try
  320.     Bmp.Palette := CopyPalette(SM.hBitmap)
  321.   finally
  322.     ReleaseStgMedium(SM)
  323.   end
  324. end;
  325.  
  326. procedure TDataObject.GetDataAsText(var Txt: String);
  327. var
  328.   SM: TStgMedium;
  329.   CTxt: PChar;
  330. begin
  331.   SetupFormatEtc(CF_TEXT, TYMED_HGLOBAL);
  332.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  333.   try
  334.     CTxt := GlobalLock(SM.hGlobal);
  335.     try
  336.       Txt := String(CTxt);
  337.     finally
  338.       GlobalUnlock(SM.hGlobal);
  339.     end
  340.   finally
  341.     ReleaseStgMedium(SM)
  342.   end
  343. end;
  344.  
  345. procedure TDataObject.GetDataAsRTF(var Txt: String);
  346. var
  347.   SM: TStgMedium;
  348.   CTxt: PChar;
  349. begin
  350.   SetupFormatEtc(CF_RTF, TYMED_HGLOBAL);
  351.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  352.   try
  353.     CTxt := GlobalLock(SM.hGlobal);
  354.     try
  355.       Txt := String(CTxt);
  356.     finally
  357.       GlobalUnlock(SM.hGlobal);
  358.     end
  359.   finally
  360.     ReleaseStgMedium(SM)
  361.   end
  362. end;
  363.  
  364. procedure TDataObject.GetDataAsFileName(var Txt: String);
  365. var
  366.   SM: TStgMedium;
  367.   CTxt: PChar;
  368. begin
  369.   SetupFormatEtc(CF_FILENAME, TYMED_HGLOBAL);
  370.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  371.   try
  372.     CTxt := GlobalLock(SM.hGlobal);
  373.     try
  374.       Txt := String(CTxt);
  375.     finally
  376.       GlobalUnlock(SM.hGlobal);
  377.     end
  378.   finally
  379.     ReleaseStgMedium(SM)
  380.   end
  381. end;
  382.  
  383. {$RangeChecks Off}
  384. procedure TDataObject.GetDataAsShellIDList(IDList: TStrings);
  385. var
  386.   SM: TStgMedium;
  387.   IDA: PIDA;
  388.   PIDL: PItemIDList;
  389.   Loop: Integer;
  390.   FileInfo: TSHFileInfo;
  391.   ParentFolder: String;
  392. begin
  393.   SetupFormatEtc(CF_IDLIST, TYMED_HGLOBAL);
  394.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  395.   try
  396.     IDA := GlobalLock(SM.hGlobal);
  397.     try
  398.       IDList.Clear;
  399.       for Loop := 0 to IDA.cidl do
  400.       begin
  401.         PIDL := PItemIDList(DWord(IDA) + IDA.aoffset[Loop]);
  402.         SHGetFileInfo(PChar(PIDL), 0, FileInfo, SizeOf(FileInfo),
  403.           SHGFI_PIDL or SHGFI_DISPLAYNAME);
  404.         if Loop = 0 then
  405.           ParentFolder := FileInfo.szDisplayName
  406.         else
  407.           if StrLen(FileInfo.szDisplayName) > 0 then
  408.             IDList.Add(ParentFolder + '\' + FileInfo.szDisplayName);
  409.       end
  410.     finally
  411.       GlobalUnlock(SM.hGlobal);
  412.     end
  413.   finally
  414.     ReleaseStgMedium(SM)
  415.   end
  416. end;
  417. {$RangeChecks On}
  418.  
  419. procedure TDataObject.GetDescriptor(SM: TStgMedium; List: TStrings);
  420. var
  421.   ObjDesc: PObjectDescriptor;
  422.   Txt: String;
  423. begin
  424.   ObjDesc := GlobalLock(SM.hGlobal);
  425.   try
  426.     List.Clear;
  427.     List.Add(Format('%s', [ClassIDToProgID(ObjDesc.clsid)]));
  428.     List.Add(Format('%s', [GuidToString(ObjDesc.clsid)]));
  429.     case ObjDesc.dwDrawAspect of
  430.       0: List.Add('App didn''t originally draw object');
  431.       DVASPECT_CONTENT: List.Add('Can be displayed as embedded content');
  432.       DVASPECT_ICON: List.Add('Iconic representation');
  433.     end;
  434.     List.Add(Format('Object extent: (%d,%d)',
  435.       [ObjDesc.size.x, ObjDesc.size.y]));
  436.     List.Add(Format('Object was clicked at: (%d,%d)',
  437.       [ObjDesc.point.x, ObjDesc.point.y]));
  438.     if ObjDesc.dwStatus <> 0 then
  439.     begin
  440.       List.Add(Format('Characteristics: ($%x)', [ObjDesc.dwStatus]));
  441.       if ObjDesc.dwStatus and OLEMISC_RECOMPOSEONRESIZE <> 0 then
  442.         List.Add('   Object wants to take charge of resizing image');
  443.       if ObjDesc.dwStatus and OLEMISC_ONLYICONIC <> 0 then
  444.         List.Add('   No useful content apart from icon');
  445.       if ObjDesc.dwStatus and OLEMISC_INSERTNOTREPLACE <> 0 then
  446.         List.Add('   Object initialised itself from data in container''s current selection');
  447.       if ObjDesc.dwStatus and OLEMISC_STATIC <> 0 then
  448.         List.Add('   Static object (no data, only presentation)');
  449.       if ObjDesc.dwStatus and OLEMISC_CANTLINKINSIDE <> 0 then
  450.         List.Add('   Cannot be link source that, when bound to, runs the object');
  451.       if ObjDesc.dwStatus and OLEMISC_CANLINKBYOLE1 <> 0 then
  452.         List.Add('   Can be linked to by OLE 1 containers');
  453.       if ObjDesc.dwStatus and OLEMISC_ISLINKOBJECT <> 0 then
  454.         List.Add('   This is a link object');
  455.       if ObjDesc.dwStatus and OLEMISC_INSIDEOUT <> 0 then
  456.         List.Add('   Can be activated in-place without menus or toolbars');
  457.       if ObjDesc.dwStatus and OLEMISC_ACTIVATEWHENVISIBLE <> 0 then
  458.         List.Add('   Should be activated whenever visible');
  459.       if ObjDesc.dwStatus and OLEMISC_RENDERINGISDEVICEINDEPENDENT <> 0 then
  460.         List.Add('   Appearance will be identical on all target devices');
  461.     end;
  462.     if ObjDesc.dwFullUserTypeName = 0 then
  463.       Txt := 'unknown user type'
  464.     else
  465.       Txt := String(PWideChar(DWord(ObjDesc) + DWord(ObjDesc.dwFullUserTypeName)));
  466.     List.Add(Format('Full user type: %s', [Txt]));
  467.     if ObjDesc.dwSrcOfCopy = 0 then
  468.       Txt := 'unknown source'
  469.     else
  470.       Txt := String(PWideChar(DWord(ObjDesc) + DWord(ObjDesc.dwSrcOfCopy)));
  471.     List.Add(Format('Transfer source: %s',
  472.       [Txt]));
  473.   finally
  474.     GlobalUnlock(SM.hGlobal);
  475.   end
  476. end;
  477.  
  478. procedure TDataObject.GetDataAsObjectDescriptor(ObjDescList: TStrings);
  479. var
  480.   SM: TStgMedium;
  481. begin
  482.   SetupFormatEtc(CF_OBJECTDESCRIPTOR, TYMED_HGLOBAL);
  483.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  484.   try
  485.     GetDescriptor(SM, ObjDescList)
  486.   finally
  487.     ReleaseStgMedium(SM)
  488.   end
  489. end;
  490.  
  491. procedure TDataObject.GetDataAsLinkSrcDescriptor(
  492.   LinkSrcDescList: TStrings);
  493. var
  494.   SM: TStgMedium;
  495. begin
  496.   SetupFormatEtc(CF_LINKSRCDESCRIPTOR, TYMED_HGLOBAL);
  497.   OleCheck(FDataObject.GetData(FFormatEtc, SM));
  498.   try
  499.     GetDescriptor(SM, LinkSrcDescList)
  500.   finally
  501.     ReleaseStgMedium(SM)
  502.   end
  503. end;
  504.  
  505. initialization
  506.   CF_FILENAME := RegisterClipboardFormat('FileName');
  507.   CF_RTF := RegisterClipboardFormat('Rich Text Format');
  508.   CF_IDLIST := RegisterClipboardFormat(CFSTR_SHELLIDLIST);
  509.   CF_OBJECTDESCRIPTOR := RegisterClipboardFormat('Object Descriptor');
  510.   CF_LINKSRCDESCRIPTOR := RegisterClipboardFormat('Link Source Descriptor');
  511. end.
  512.